home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / pcl-rev4.lha / combin.lisp < prev    next >
Lisp/Scheme  |  1990-05-01  |  11KB  |  274 lines
  1. ;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. (defun make-effective-method-function (generic-function form)
  31.   (flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
  32.     (if (and (listp form)
  33.          (eq (car form) 'call-method)
  34.          (method-p (cadr form))
  35.          (every #'method-p (caddr form)))
  36.     ;;
  37.     ;; The effective method is just a call to call-method.  This opens up
  38.     ;; the possibility of just using the method function of the method as
  39.     ;; as the effective method function.
  40.     ;;
  41.     ;; But we have to be careful.  If that method function will ask for
  42.     ;; the next methods we have to provide them.  We do not look to see
  43.     ;; if there are next methods, we look at whether the method function
  44.     ;; asks about them.  If it does, we must tell it whether there are
  45.     ;; or aren't to prevent the leaky next methods bug.
  46.     ;; 
  47.     (let* ((method-function (method-function (cadr form)))
  48.            (arg-info (gf-arg-info generic-function))
  49.            (metatypes (arg-info-metatypes arg-info))
  50.            (applyp (arg-info-applyp arg-info)))
  51.       (if (not (method-function-needs-next-methods-p method-function))
  52.           method-function
  53.           (let ((next-method-functions (mapcar #'method-function (caddr form))))
  54.         (name-function
  55.           (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
  56.                    (let ((*next-methods* .next-method-functions.))
  57.                      ,(make-dfun-call metatypes applyp '.method-function.)))
  58.             #'default-test-converter    ;This could be optimized by making
  59.                         ;the interface from here to the
  60.                         ;walker more clear so that the
  61.                         ;form wouldn't get walked at all.
  62.             #'(lambda (form)
  63.             (if (memq form '(.next-method-functions. .method-function.))
  64.                 (values form (list form))
  65.                 form))
  66.             #'(lambda (form)
  67.             (cond ((eq form '.next-method-functions.)
  68.                    (list next-method-functions))
  69.                   ((eq form '.method-function.)
  70.                    (list method-function)))))))))
  71.     ;;
  72.     ;; We have some sort of `real' effective method.  Go off and get a
  73.     ;; compiled function for it.  Most of the real hair here is done by
  74.     ;; the GET-FUNCTION mechanism.
  75.     ;; 
  76.     (name-function (make-effective-method-function-internal generic-function form)))))
  77.  
  78. (defvar *global-effective-method-gensyms* ())
  79. (defvar *rebound-effective-method-gensyms*)
  80.  
  81. (defun get-effective-method-gensym ()
  82.   (or (pop *rebound-effective-method-gensyms*)
  83.       (let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
  84.     (push new *global-effective-method-gensyms*)
  85.     new)))
  86.  
  87. (eval-when (load)
  88.   (let ((*rebound-effective-method-gensyms* ()))
  89.     (dotimes (i 10) (get-effective-method-gensym))))
  90.  
  91. (defun make-effective-method-function-internal (generic-function effective-method)
  92.   (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
  93.      (arg-info (gf-arg-info generic-function))
  94.      (metatypes (arg-info-metatypes arg-info))
  95.      (applyp (arg-info-applyp arg-info)))
  96.     (labels ((test-converter (form)
  97.            (if (and (consp form) (eq (car form) 'call-method))
  98.            '.call-method.
  99.            (default-test-converter form)))
  100.          (code-converter (form)
  101.            (if (and (consp form) (eq (car form) 'call-method))
  102.            ;;
  103.            ;; We have a `call' to CALL-METHOD.  There may or may not be next methods
  104.            ;; and the two cases are a little different.  It controls how many gensyms
  105.            ;; we will generate.
  106.            ;;
  107.            (let ((gensyms
  108.                (if (cddr form)
  109.                    (list (get-effective-method-gensym)
  110.                      (get-effective-method-gensym))
  111.                    (list (get-effective-method-gensym)
  112.                      ()))))
  113.              (values `(let ((*next-methods* ,(cadr gensyms)))
  114.                 ,(make-dfun-call metatypes applyp (car gensyms)))
  115.                  gensyms))
  116.            (default-code-converter form)))
  117.          (constant-converter (form)
  118.            (if (and (consp form) (eq (car form) 'call-method))
  119.            (if (cddr form)
  120.                (list (check-for-make-method (cadr form))
  121.                  (mapcar #'check-for-make-method (caddr form)))
  122.                (list (check-for-make-method (cadr form))
  123.                  ()))
  124.            (default-constant-converter form)))
  125.          (check-for-make-method (effective-method)
  126.            (cond ((method-p effective-method)
  127.               (method-function effective-method))
  128.              ((and (listp effective-method)
  129.                (eq (car effective-method) 'make-method))
  130.               (make-effective-method-function generic-function
  131.                               (make-progn (cadr effective-method))))
  132.              (t
  133.               (error "Effective-method form is malformed.")))))
  134.       (get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
  135.           #'test-converter
  136.           #'code-converter
  137.           #'constant-converter))))
  138.  
  139.  
  140.  
  141. (defvar *invalid-method-error*
  142.     #'(lambda (&rest args)
  143.         (declare (ignore args))
  144.         (error
  145.           "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
  146.                of a method combination function (inside the body of~%~
  147.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  148.                function COMPUTE-EFFECTIVE-METHOD).")))
  149.  
  150. (defvar *method-combination-error*
  151.     #'(lambda (&rest args)
  152.         (declare (ignore args))
  153.         (error
  154.           "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
  155.                of a method combination function (inside the body of~%~
  156.                DEFINE-METHOD-COMBINATION or a method on the generic~%~
  157.                function COMPUTE-EFFECTIVE-METHOD).")))
  158.  
  159. ;(defmethod compute-effective-method :around        ;issue with magic
  160. ;       ((generic-function generic-function)     ;generic functions
  161. ;        (method-combination method-combination)
  162. ;        applicable-methods)
  163. ;  (declare (ignore applicable-methods))
  164. ;  (flet ((real-invalid-method-error (method format-string &rest args)
  165. ;       (declare (ignore method))
  166. ;       (apply #'error format-string args))
  167. ;     (real-method-combination-error (format-string &rest args)
  168. ;       (apply #'error format-string args)))
  169. ;    (let ((*invalid-method-error* #'real-invalid-method-error)
  170. ;      (*method-combination-error* #'real-method-combination-error))
  171. ;      (call-next-method))))
  172.  
  173. (defun invalid-method-error (&rest args)
  174.   (declare (arglist method format-string &rest format-arguments))
  175.   (apply *invalid-method-error* args))
  176.  
  177. (defun method-combination-error (&rest args)
  178.   (declare (arglist format-string &rest format-arguments))
  179.   (apply *method-combination-error* args))
  180.  
  181.  
  182.  
  183. ;;;
  184. ;;; The STANDARD method combination type.  This is coded by hand (rather than
  185. ;;; with define-method-combination) for bootstrapping and efficiency reasons.
  186. ;;; Note that the definition of the find-method-combination-method appears in
  187. ;;; the file defcombin.lisp, this is because EQL methods can't appear in the
  188. ;;; bootstrap.
  189. ;;;
  190. ;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
  191. ;;; classes has to appear here for this reason.  This code must conform to
  192. ;;; the code in the file defcombin, look there for more details.
  193. ;;;
  194.  
  195. (defclass method-combination () ())
  196.  
  197. (define-gf-predicate method-combination-p method-combination)
  198.  
  199. (defclass standard-method-combination
  200.       (definition-source-mixin method-combination)
  201.      ((type          :reader method-combination-type
  202.                  :initarg :type)
  203.       (documentation :reader method-combination-documentation
  204.              :initarg :documentation)
  205.       (options       :reader method-combination-options
  206.                  :initarg :options)))
  207.  
  208. (defmethod print-object ((mc method-combination) stream)
  209.   (printing-random-thing (mc stream)
  210.     (format stream
  211.         "Method-Combination ~S ~S"
  212.         (method-combination-type mc)
  213.         (method-combination-options mc))))
  214.  
  215. (eval-when (load eval)
  216.   (setq *standard-method-combination*
  217.     (make-instance 'standard-method-combination
  218.                :type 'standard
  219.                :documentation "The standard method combination."
  220.                :options ())))
  221.  
  222. ;This definition appears in defcombin.lisp.
  223. ;
  224. ;(defmethod find-method-combination ((generic-function generic-function)
  225. ;                     (type (eql 'standard))
  226. ;                     options)
  227. ;  (when options
  228. ;    (method-combination-error
  229. ;      "The method combination type STANDARD accepts no options."))
  230. ;  *standard-method-combination*)
  231.  
  232. (defun make-call-methods (methods)
  233.   (mapcar #'(lambda (method) `(call-method ,method ())) methods))
  234.  
  235. (defmethod compute-effective-method ((generic-function generic-function)
  236.                      (combin standard-method-combination)
  237.                      applicable-methods)
  238.   (let ((before ())
  239.     (primary ())
  240.     (after ())
  241.     (around ()))
  242.     (dolist (m applicable-methods)
  243.       (let ((qualifiers (method-qualifiers m)))
  244.     (cond ((member ':before qualifiers)  (push m before))
  245.           ((member ':after  qualifiers)  (push m after))
  246.           ((member ':around  qualifiers) (push m around))
  247.           (t
  248.            (push m primary)))))
  249.     (setq before  (reverse before)
  250.       after   (reverse after)
  251.       primary (reverse primary)
  252.       around  (reverse around))
  253.     (cond ((null primary)
  254.        `(error "No primary method for the generic function ~S." ',generic-function))
  255.       ((and (null before) (null after) (null around))
  256.        ;;
  257.        ;; By returning a single call-method `form' here we enable an important
  258.        ;; implementation-specific optimization.
  259.        ;; 
  260.        `(call-method ,(first primary) ,(rest primary)))
  261.       (t
  262.        (let ((main-effective-method
  263.            (if (or before after (rest primary))
  264.                `(multiple-value-prog1
  265.               (progn ,@(make-call-methods before)
  266.                  (call-method ,(first primary) ,(rest primary)))
  267.               ,@(make-call-methods (reverse after)))
  268.                `(call-method ,(first primary) ()))))
  269.          (if around
  270.          `(call-method ,(first around)
  271.                    (,@(rest around) (make-method ,main-effective-method)))
  272.          main-effective-method))))))
  273.  
  274.